Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Byte, Source As Byte, ByVal Length As Long)
Dim wArr(30, 2)       As String
Private Sub Command1_Click()
    If sockServer(0).State <> sckClosed Then sockServer(0).Close    '判断是否处于监听状态,如果处于监听状态,那么关闭控件
    sockServer(0).LocalPort = "1228"                                '设置监听端口为1228
    sockServer(0).Listen                                            '开始监听
StateInfo.Text = "开始侦听"                                          '在TEXT控件中显示状态
    Me.SockList.AddItem "sockserver(0) 开始侦听"                        '添加到事件列表
    Command1.Enabled = False                                            '更改开启服务按钮的状态
    Command2.Enabled = True           '更改关闭退出按钮的状态
End Sub
                                                                         
Private Sub Command2_Click()
    Unload Me                     '关闭窗体,关闭网络控件的代码我放在FROM_UNLOAD中
End Sub
                                                                         
Private Sub Form_Unload(Cancel As Integer)
    If sockServer(0).State <> sckClosed Then                    '判断服务器端是否关闭
        sockServer(0).Close                                      '关闭服务端连接
    End If
End Sub
                                                               
Public Function RsToBin(Rs As Recordset) As Variant              '记录集转换为二进制数据
    Dim objStream As Stream
    Set objStream = New Stream
    objStream.Open
    objStream.Type = adTypeBinary
    Rs.Save objStream, adPersistADTG
    objStream.Position = 0
    RsToBin = objStream.Read()
    Set objStream = Nothing
End Function
                                                                    
Private Sub sockServer_Close(Index As Integer)
 On Error GoTo acd
  SockList.AddItem "客户端:" & sockServer(Index).RemoteHostIP & "已经关闭连接"     '添加客户端关闭到事件列表
  wArr(Index, 0) = ""                              '更改数组的状态为关闭
  Unload sockServer(Index)                         '释放相应的SOCK控件
  Exit Sub
acd:
End Sub

Private Sub sockServer_ConnectionRequest(Index As Integer, ByVal requestID As Long)   '服务器收到连接请求后
Dim i As Integer, pi As Integer
  Dim bi As Boolean
  If Index = 0 Then
          For i = 1 To 30                            '循环整个数组,判断是否有连接可用
                  If wArr(i, 0) = "" Then            '搜索到没有装载的控件时
                          pi = i                     '记录控件序号
                          bi = True                  '记录有可用控件
                          Exit For
                  End If
          Next i
            
          If bi = True Then              '当有可用控件时
                  wArr(pi, 0) = sockServer(0).RemoteHostIP          '将客户端IP记录到数组
                  Load sockServer(pi)                               '装载相应的控件
                  sockServer(pi).LocalPort = 10000 + pi             '设置连接端口为10000+控件序号
                  sockServer(pi).Accept requestID                   '回应连接请求并允许连接
                  SockList.AddItem "客户端:" & sockServer(pi).RemoteHostIP & "已经连接"    '添加到事件列表
          Else
                  MsgBox "客户端连接已满"           '连接数已满的情况下显示消息
          End If
  End If
End Sub

Private Sub sockServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
    Dim strsql As String
    Dim objRec As Recordset
    Dim arrData() As Byte
    Dim arrLength As Long
    Dim FinisData() As Byte
    Dim cnn As New ADODB.Connection
    Dim Rs As New ADODB.Recordset
    sockServer(Index).GetData strsql
    'Set objRec = GetRecordset(strsql)                                          ' 执行接受到的查询，其中GetRecordset方法执行SQL语句并返回一记录集
    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\wlbkcgl.mdb;Persist Security Info=False"        '定义ADO连接字符
    Rs.Open strsql, cnn, adOpenKeyset, adLockOptimistic                         '返回查询结果
    arrData() = RsToBin(Rs)                                                     ' 记录集转换成字节数组
    arrLength = UBound(arrData)                                                  '获取字节数组长度
    Set Rs = Nothing                                                             '释放
    Set cnn = Nothing                                                             '释放
    FinisData = "`!" '添加数据包结束标志
    ReDim Preserve arrData(arrLength + 4)                                          '不破坏原有数据的情况下重定义原有二进制数组
    CopyMemory arrData(arrLength + 1), FinisData(0), 4                              'API命令,添加数据包结果标志到二进制数组结尾
    sockServer(Index).SendData arrData                                                 ' 送回客户段
    DoEvents                                                                          '转移控制权,以处理其它客户端的响应
End Sub
